home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / backend / codegen.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  25.4 KB  |  714 lines  |  [TEXT/CCL2]
  1. ;;; codegen.scm -- compile flic code to Lisp
  2. ;;;
  3. ;;; Author :  Sandra Loosemore
  4. ;;; Date   :  29 Apr 1992
  5. ;;;
  6. ;;; to do:  check completeness of special cases for constructors
  7. ;;;         constants still need work
  8. ;;;         optimized entry points
  9. ;;;
  10. ;;; The code generated here uses the following helper functions:
  11. ;;; (make-curried-fn opt-fn strictness)
  12. ;;;   make a curried function that calls opt-fn after collecting the
  13. ;;;   arguments and processing them according to strictness.  Both
  14. ;;;   the arguments are evaluated.
  15. ;;; (make-tuple-constructor arity strictness)
  16. ;;;   return a function that makes an untagged data structure with "arity" 
  17. ;;;   slots.  "arity" is a constant.
  18. ;;; (make-tuple . args)
  19. ;;;   uncurried version of the above
  20. ;;; (make-tagged-data-constructor n arity strictness)
  21. ;;;   return a function that makes a data structure with tag "n" and
  22. ;;;   "arity" slots.
  23. ;;; (make-tagged-data n . args)
  24. ;;;   uncurried version of the above
  25. ;;; (tuple-select arity i object)
  26. ;;;   extract component "i" from untagged "object"
  27. ;;; (tagged-data-select arity i object)
  28. ;;;   extract component "i" from tagged "object"
  29. ;;; (constructor-number object)
  30. ;;;   return the tag from "object"
  31. ;;; (delay form)
  32. ;;;   returns a delay object with unevaluated "form".
  33. ;;; (box form)
  34. ;;;   returns a delay object with evaluated "form".
  35. ;;; (force delay)
  36. ;;;   return the value of the delay object.
  37. ;;; (make-haskell-string string)
  38. ;;;   Converts a Lisp string lazily to a haskell string (using a magic
  39. ;;;   delay function).  Returns an unboxed result.
  40.  
  41.  
  42.  
  43. ;;;======================================================================
  44. ;;; Code walker
  45. ;;;======================================================================
  46.  
  47.  
  48. ;;; Here is the main entry point.
  49.  
  50. (define *interface-vars-referenced*  '())
  51.  
  52. (define (codegen-top big-let)
  53.   (if (flic-void? big-let)
  54.       `(begin
  55.      ,@(codegen-initcode '()))
  56.       (dynamic-let ((*interface-vars-referenced*  '()))
  57.         (do ((bindings (flic-let-bindings big-let) (cdr bindings))
  58.          (functions   '())
  59.          (predefines  '())
  60.          (inits       '()))
  61.           ((null? bindings)
  62.          `(begin ,@(nreverse predefines)
  63.              ,@(map (lambda (v) `(predefine ,(fullname v)))
  64.                 (dynamic *interface-vars-referenced*))
  65.              ,@(nreverse functions)
  66.              ,@(codegen-initcode (nreverse inits))))
  67.          (let ((var  (car bindings)))
  68.           (when (or (memq 'codegen (dynamic *printers*))
  69.                 (memq 'codegen-flic (dynamic *printers*)))
  70.             (format '#t "~%Codegen of ~A  " (def-name var))
  71.             (when (not (var-strict? var))
  72.           (format '#t "Nonstrict  "))
  73.             (when (not (eq? (var-strictness var) '()))
  74.           (format '#t "Strictness: ")
  75.           (dolist (s (var-strictness var))
  76.             (format '#t (if s "S " "N "))))
  77.         (when (var-simple? var)
  78.           (format '#t " Inline "))
  79.         (format '#t "~%")
  80.         (when (memq 'codegen-flic (dynamic *printers*))
  81.           (pprint* (var-value var))))
  82.           (multiple-value-bind (function predefine init)
  83.           (codegen-definition var (var-value var))
  84.         (when (or (memq 'codegen (dynamic *printers*))
  85.               (memq 'codegen-flic (dynamic *printers*)))
  86.           (when function (pprint* function))
  87.           (when init (pprint* init)))
  88.         (when function (push function functions))
  89.         (when predefine (push predefine predefines))
  90.         (when init (push init inits))))))))
  91.  
  92.  
  93. ;;; Chunk initialization forms into reasonably-sized functions to avoid
  94. ;;; giving the Lisp compiler too much trouble with them.
  95.  
  96. (define *initcode-chunk-size* 20)
  97. (define *initcode-function-name* 'initcode)
  98. (define *initcode-function* '#f)
  99.  
  100.  
  101. (define (codegen-initcode inits)
  102.   (let ((fn-name  (dynamic *initcode-function-name*)))
  103.     `(,@(if (> (the fixnum (length inits)) (the fixnum *initcode-chunk-size*))
  104.         (multiple-value-bind (fn-defs fn-calls)
  105.         (codegen-initcode-aux inits fn-name 1)
  106.           `(,@fn-defs
  107.         (define (,fn-name) ,@fn-calls '#t)))
  108.         `((define (,fn-name) ,@inits '#t)))
  109.       (setf *initcode-function* (function ,fn-name))
  110.       (,fn-name))))
  111.        
  112.  
  113. (define (codegen-initcode-aux inits fn-name part)
  114.   (let ((tail  (list-tail inits *initcode-chunk-size*))
  115.     (name  (string->symbol (format '#f "~a-part~a" fn-name part))))
  116.     (if (or (null? tail) (null? (cdr tail)))
  117.     (values
  118.       (list `(define (,name) ,@inits))
  119.       (list `(,name)))
  120.     (let ((next  (cdr tail)))
  121.       (setf (cdr tail) '())
  122.       (multiple-value-bind (fn-defs fn-calls)
  123.           (codegen-initcode-aux next fn-name (1+ part))
  124.         (values
  125.           (cons `(define (,name) ,@inits) fn-defs)
  126.           (cons `(,name) fn-calls))))
  127.       )))
  128.  
  129.  
  130.  
  131. ;;; For top-level definitions bound to lambda expressions, make both
  132. ;;; a standard entry point (with possibly unboxed arguments) and
  133. ;;; a standard entry point.
  134.  
  135. (define (codegen-definition var exp)
  136.   (let ((fullname  (fullname var)))
  137.     (if (not (flic-lambda? exp))
  138.     ;; Simple variable definition only.
  139.     (values
  140.       '#f
  141.       `(define ,fullname '#f)
  142.       `(setf ,fullname ,(do-codegen exp)))
  143.     (let* ((optname  (optname var))
  144.            (lambda   (codegen-lambda-aux exp))
  145.            (def      `(define (,optname ,@(cadr lambda))
  146.                 ,@(cddr lambda))))
  147.       (if (var-selector-fn? var)
  148.           ;; Standard entry point for selectors is never used,
  149.           ;; so don't generate variable definition.
  150.           (values
  151.             def
  152.         '#f
  153.         '#f)
  154.           ;; Generate both function and variable definitions.
  155.           (values
  156.             def
  157.         `(define ,fullname '#f)
  158.         `(setf ,fullname
  159.                ,(maybe-make-box-value
  160.               (codegen-curried-fn
  161.                `(function ,optname) (var-strictness var))
  162.               (var-strict? var))))
  163.         )))))
  164.  
  165.  
  166.  
  167. ;;; See box.scm for more information about this...
  168.  
  169. (define (do-codegen object)
  170.   (let ((x               (codegen object))
  171.     (unboxed?        (flic-exp-unboxed? object))
  172.     (strict-result?  (flic-exp-strict-result? object))
  173.     (cheap?          (flic-exp-cheap? object)))
  174.     (if unboxed?
  175.     (if strict-result?
  176.         x
  177.         (if cheap?
  178.         `(unbox ,x)
  179.         (make-force x)))
  180.     (if strict-result?
  181.         (if (and (pair? x)
  182.              (or (eq? (car x) 'delay-funcall)
  183.              (eq? (car x) 'delay-funcall/force)))
  184.         ;; see flic-app, below
  185.         x
  186.         (if cheap?
  187.             `(box ,x)
  188.             `(delay ,x ,(thunk-name object))))
  189.         (if cheap?
  190.         x
  191.         `(delay (force ,x) ,(thunk-name object)))))
  192.     ))
  193.  
  194.  
  195. ;;; Some accessors have equivalents that do the force.
  196.  
  197. (define *force-equivalents*
  198.   '((car . force-car)
  199.     (cdr . force-cdr)
  200.     (tuple-select . force-tuple-select)
  201.     (tagged-data-select . force-tagged-data-select)
  202.     (car/force . force-car/force)
  203.     (cdr/force . force-cdr/force)
  204.     (tuple-select/force . force-tuple-select/force)
  205.     (tagged-data-select/force . force-tagged-data-select/force)
  206.     ))
  207.  
  208. (define (make-force x)
  209.   (if (pair? x)
  210.       (let ((stuff  (assq (car x) *force-equivalents*)))
  211.     (if stuff
  212.         `(,(cdr stuff) ,@(cdr x))
  213.         `(force ,x)))
  214.       `(force, x)))
  215.  
  216.  
  217. ;;; This is used to give thunks meaningful function names for debugging
  218. ;;; purposes.
  219.  
  220. (define (thunk-name object)
  221.   (dynamic-let ((*print-length*  3)
  222.         (*print-level*   3)
  223.         (*print-pretty*  '#f))
  224.     (string->gensym (format '#f "Delay ~s" object))))
  225.     
  226.  
  227.  
  228.  
  229. ;;; Here is the code walker definition.
  230.  
  231. (define (do-codegen-list list)
  232.   (map (function do-codegen) list))
  233.  
  234. (define-flic-walker codegen (object))
  235.  
  236.  
  237. (define (codegen-lambda-list vars)
  238.   (map (function fullname) vars))
  239.  
  240. (define (codegen-curried-fn opt-fn strictness)
  241.   (if (null? (cdr strictness))
  242.       ;; one-argument special cases
  243.       (if (car strictness)
  244.       `(make-curried-fn-1-strict ,opt-fn)
  245.       `(make-curried-fn-1-nonstrict ,opt-fn))
  246.       ;; general case
  247.       `(make-curried-fn ,opt-fn ',strictness)))
  248.  
  249.  
  250. ;;; Curry lambdas.  Functions always return an unboxed value.
  251. ;;; Also note that anonymous lambdas always have all non-strict arguments.
  252.  
  253. (define-codegen flic-lambda (object)
  254.   (codegen-curried-fn
  255.     (codegen-lambda-aux object)
  256.     (map (function var-strict?) (flic-lambda-vars object))))
  257.  
  258. (define (codegen-lambda-aux object)
  259.   (let* ((vars    (flic-lambda-vars object))
  260.      (ignore  '())
  261.      (args    (codegen-lambda-list vars)))
  262.     (dolist (v vars)
  263.       (if (eqv? (var-referenced v) 0)
  264.       (push (fullname v) ignore)))
  265.     `(lambda ,args
  266.        ,@(if (not (null? ignore))
  267.          `((declare (ignore ,@ignore)))
  268.          '())
  269.        ,(do-codegen (flic-lambda-body object)))))
  270.  
  271.  
  272. ;;; This is only for non-top-level lets.
  273. ;;; The boxing of the value of each of the bindings is controlled by its
  274. ;;; strict? property.
  275.  
  276. (define-codegen flic-let (object)
  277.   (let ((bindings   (flic-let-bindings object))
  278.     (body       (flic-let-body object))
  279.     (recursive? (flic-let-recursive? object)))
  280.     (if recursive?
  281.     (codegen-letrec bindings body)
  282.     (codegen-let*   bindings body))))
  283.  
  284.  
  285. ;;; For efficiency reasons, we want to make all the function bindings
  286. ;;; in th-app-fn object))
  287.     (args       (flic-app-args object))
  288.     (saturated? (flic-app-saturated? object)))
  289.     (cond ((and saturated? (flic-pack? fn))
  290.        ;; Saturated call to constructor
  291.        (codegen-constructor-app-aux
  292.          (flic-pack-con fn)
  293.          (do-codegen-list args)))
  294.       ((and saturated? (flic-ref? fn))
  295.        ;; Saturated call to named function
  296.        (codegen-named-funcall (flic-ref-var fn) args))
  297.       (else
  298.        ;; Have to make a curried call to standard entry point.
  299.        (let ((fncode   (do-codegen fn))
  300.          (argcode  (do-codegen-list args)))
  301.          (if (and (pair? fncode)
  302.               (eq? (car fncode) 'force))
  303.          `(funcall/force ,(cadr fncode) ,@argcode)
  304.          `(funcall ,fncode ,@argcode))))
  305.       )))
  306.  
  307. (define (codegen-constructor-app-aux con argcode)
  308.   (let ((alg  (con-alg con)))
  309.     (cond ((eq? con (core-symbol ":"))
  310.        `(cons ,@argcode))
  311.       ((algdata-implemented-by-lisp? alg)
  312.        (apply-maybe-lambda (cadr (con-lisp-fns con)) argcode))
  313.       ((algdata-tuple? alg)
  314.        `(make-tuple ,@argcode))
  315.       (else
  316.        `(make-tagged-data ,(con-tag con) ,@argcode)))))
  317.  
  318.  
  319. ;;; Look for hacks for generating better code for certain primitive
  320. ;;; functions.
  321.  
  322. (define (codegen-named-funcall var args)
  323.   (cond ((eq? var (core-symbol "strict2"))
  324.      ;; Could be smarter about detecting do-nothing cases for
  325.      ;; the first argument here....
  326.      `(begin ,@(do-codegen-list args)))
  327.     ((and (eq? var (core-symbol "error"))
  328.           (is-type? 'flic-const (car args)))
  329.      `(prim.abort ,(flic-const-value (car args))))
  330.     ((and (eq? var (core-symbol "stringToSymbol"))
  331.           (is-type? 'flic-const (car args)))
  332.      `',(string->symbol (flic-const-value (car args))))
  333.     ((and (eq? var (core-symbol "applyIO"))
  334.           (is-type? 'flic-lambda (cadr args))
  335.           (null? (cdr (flic-lambda-vars (cadr args))))
  336.           (var-strict? (car (flic-lambda-vars (cadr args)))))
  337.      (codegen-applyio
  338.        (car args)
  339.        (car (flic-lambda-vars (cadr args)))
  340.        (flic-lambda-body (cadr args))))
  341.     (else
  342.      (let ((optname (optname var))
  343.            (argcode (do-codegen-list args)))
  344.        `(,optname ,@argcode)))))
  345.  
  346.  
  347. ;;; Turn nested applyio calls into LET* constructs, e.g.
  348. ;;;   applyio (p s) (\x -> applyio (q x s) (\y -> r y s))
  349. ;;; turns into
  350. ;;;   (let* ((x    (p s))
  351. ;;;          (y    (q x s)))
  352. ;;;      (r y s))
  353.  
  354. (define (codegen-applyio arg1 var body)
  355.   (let ((arg1-code  (do-codegen arg1))
  356.     (body-code  (do-codegen body))
  357.     (ignore     (if (eqv? (var-referenced var) 0)
  358.             `((declare (ignore ,(fullname var))))
  359.             '())))
  360.     (if (and (pair? body-code)
  361.          (eq? (car body-code) 'let*))
  362.     `(let* ((,(fullname var) ,arg1-code)
  363.         ,@(cadr body-code))
  364.        ,@ignore
  365.        ,@(cddr body-code))
  366.     `(let* ((,(fullname var) ,arg1-code))
  367.        ,@ignore
  368.        ,body-code))))
  369.  
  370.  
  371. ;;; We need to keep track of external variables from interface files
  372. ;;; so we can do something to suppress compiler warnings about references
  373. ;;; to undeclared variables.
  374.  
  375. (define-codegen flic-ref (object)
  376.   (let ((var  (flic-ref-var object)))
  377.     (when (def-interface? var)
  378.       (when (not (memq var (dynamic *interface-vars-referenced*)))
  379.     (push var (dynamic *interface-vars-referenced*))))
  380.     (fullname var)))
  381.  
  382.  
  383. (define-codegen flic-const (object)
  384.   (let ((value   (flic-const-value object)))
  385.     (cond ((string? value)
  386.        `(make-haskell-string ,value))
  387.       ((char? value)
  388.        ;; *** I think the parser ought to convert characters to their
  389.        ;; *** ASCII codes instead of doing it here.  There are problems
  390.        ;; *** with valid Haskell characters that can't be represented
  391.        ;; *** portably as Lisp characters.
  392.        (char->integer value))
  393.       ((number? value)
  394.        value)
  395.       (else
  396.        ;; It must be a ratio.  This is a bit of a hack - this depends on
  397.        ;; the fact that 2 tuples are represented in the same manner as
  398.        ;; rationals.  Hacked for strict rationals - jcp
  399.        `(make-tuple ,(car value) ,(cadr value)))
  400.       )))
  401.  
  402.  
  403. ;;; Returns a function or constant, so doesn't need to delay result.
  404. ;;; See flic-app for handling of saturated constructor calls.
  405.  
  406. (define-codegen flic-pack (object)
  407.   (let* ((con        (flic-pack-con object))
  408.      (arity      (con-arity con))
  409.      (alg        (con-alg con))
  410.      (tuple?     (algdata-tuple? alg))
  411.      (strictness (con-slot-strict? con))
  412.      (index      (con-tag con)))
  413.     (cond ((eq? con (core-symbol "Nil"))
  414.        ''())
  415.       ((eq? con (core-symbol "True"))
  416.        ''#t)
  417.       ((eq? con (core-symbol "False"))
  418.        ''#f)
  419.       ((eq? con (core-symbol ":"))
  420.        '(function cons-constructor))
  421.       ((algdata-implemented-by-lisp? alg)
  422.        (let ((fn (cadr (con-lisp-fns con))))
  423.          (if (eqv? (con-arity con) 0)
  424.          fn
  425.          (codegen-curried-fn
  426.           (if (and (pair? fn) (eq? (car fn) 'lambda))
  427.               fn
  428.               `(function ,fn))
  429.           strictness))))
  430.       ((algdata-enum? alg)
  431.        ;; All constructors have 0 arity; represent them just
  432.        ;; by numbers.
  433.        index)
  434.       (tuple?
  435.        ;; Only a single constructor for this type.
  436.        `(make-tuple-constructor ,arity ',strictness))
  437.       ((eqv? arity 0)
  438.        ;; No arguments to this constructor.
  439.        `(make-tagged-data ,index))
  440.       (else
  441.        ;; General case.
  442.        `(make-tagged-data-constructor ,index ,arity ',strictness))
  443.       )))
  444.  
  445.  
  446.  
  447. ;;; These expressions translate directly into their Lisp equivalents.
  448.  
  449. (define-codegen flic-case-block (object)
  450.   `(block ,(flic-case-block-block-name object)
  451.      ,@(do-codegen-list (flic-case-block-exps object))))
  452.  
  453. (define-codegen flic-return-from (object)
  454.   `(return-from ,(flic-return-from-block-name object)
  455.         ,(do-codegen (flic-return-from-exp object))))
  456.  
  457. (define-codegen flic-and (object)
  458.   `(and ,@(do-codegen-list (flic-and-exps object))))
  459.  
  460. (define-codegen flic-if (object)
  461.   `(if ,(do-codegen (flic-if-test-exp object))
  462.        ,(do-codegen (flic-if-then-exp object))
  463.        ,(do-codegen (flic-if-else-exp object))))
  464.  
  465. (define-codegen flic-sel (object)
  466.   (codegen-flic-sel-aux
  467.     (flic-sel-con object)
  468.     (flic-sel-i object)
  469.     (do-codegen (flic-sel-exp object))))
  470.  
  471. (define (codegen-flic-sel-aux con index exp)
  472.   (let* ((alg      (con-alg con))
  473.      (tuple?   (algdata-tuple? alg))
  474.      (arity    (con-arity con))
  475.      (force?   (and (pair? exp)
  476.             (eq? (car exp) 'force))))
  477.     (cond ((eq? con (core-symbol ":"))
  478.        (if (eqv? index 0)
  479.            (if force?
  480.            `(car/force ,(cadr exp))
  481.            `(car ,exp))
  482.            (if force?
  483.            `(cdr/force ,(cadr exp))
  484.            `(cdr ,exp))))
  485.       ((algdata-implemented-by-lisp? alg)
  486.        (apply-maybe-lambda (list-ref (cddr (con-lisp-fns con)) index)
  487.                    (list exp)))
  488.       (tuple?
  489.        (if force?
  490.            `(tuple-select/force ,arity ,index ,(cadr exp))
  491.            `(tuple-select ,arity ,index ,exp)))
  492.       (else
  493.        (if force?
  494.            `(tagged-data-select/force ,arity ,index ,(cadr exp))
  495.            `(tagged-data-select ,arity ,index ,exp)))
  496.       )))
  497.  
  498. (define-codegen flic-is-constructor (object)
  499.   (codegen-flic-is-constructor-aux
  500.     (flic-is-constructor-con object)
  501.     (do-codegen (flic-is-constructor-exp object))))
  502.  
  503. (define (codegen-flic-is-constructor-aux con exp)
  504.   (let ((type (con-alg con)))
  505.     (cond ((eq? type (core-symbol "Bool"))
  506.        (if (eq? con (core-symbol "True"))
  507.            exp
  508.            `(not ,exp)))
  509.       ((eq? type (core-symbol "List"))
  510.        (if (eq? con (core-symbol ":"))
  511.            `(pair? ,exp)
  512.            `(null? ,exp)))
  513.       ((algdata-implemented-by-lisp? type)
  514.        (let ((fn (car (con-lisp-fns con))))
  515.          (apply-maybe-lambda fn (list exp))))
  516.       ;; Use the is-constructor to actually force the data value.
  517.       ;; The expression must be referenced to ensure the forcing
  518.       ;; takes place.
  519.       ((algdata-tuple? type)  ; this may force the exp
  520.        `(begin ,exp '#t))
  521.       ((algdata-enum? type)
  522.        `(eqv? (the fixnum ,exp) (the fixnum ,(con-tag con))))
  523.       (else
  524.        `(eqv? (the fixnum (constructor-number ,exp))
  525.           (the fixnum ,(con-tag con))))
  526.       )))
  527.  
  528.  
  529. (define-codegen flic-con-number (object)
  530.   (let ((type   (flic-con-number-type object))
  531.     (exp    (do-codegen (flic-con-number-exp object))))
  532.     `(the fixnum
  533.       ,(cond ((eq? type (core-symbol "Bool"))
  534.           `(if ,exp 1 0))
  535.          ((eq? type (core-symbol "List"))
  536.           `(if (pair? ,exp) 0 1))
  537.          ((algdata-tuple? type)
  538.           ;; This should never happen.
  539.           0)
  540.          ((algdata-implemented-by-lisp? type)
  541.           (let ((var (gensym)))
  542.             `(let ((,var ,exp))
  543.                (cond ,@(map (lambda (con)
  544.                       `(,(apply-maybe-lambda
  545.                       (car (con-lisp-fns con))
  546.                       (list var))
  547.                     ',(con-tag con)))
  548.                     (algdata-constrs type))
  549.                  (else (error "No constructor satisfies ~A.~%"
  550.                       ',(def-name type)))))))
  551.          ((algdata-enum? type)
  552.           exp)
  553.          (else
  554.           `(constructor-number ,exp))
  555.          ))
  556.     ))
  557.  
  558.  
  559.  
  560.  
  561. (define-codegen flic-update (object)
  562.   (let* ((con    (flic-update-con object))
  563.      (arity  (con-arity con))
  564.      (slots  (flic-update-slots object))
  565.      (exp    (flic-update-exp object))
  566.      (temp   (gensym))
  567.      (args   '()))
  568.     (dotimes (i arity)
  569.       (let ((s  (assv i slots)))
  570.     (if s
  571.         (push (do-codegen (cdr s)) args)
  572.         (push (codegen-flic-sel-aux con i temp) args))))
  573.     `(let ((,temp  ,(do-codegen exp)))
  574.        ,(codegen-constructor-app-aux con (nreverse args)))
  575.     ))
  576.  
  577.  
  578. ;;;======================================================================
  579. ;;; Utility functions
  580. ;;;======================================================================
  581.  
  582. ;;; Here are some helper functions for handing boxing and unboxing
  583. ;;; of values.
  584. ;;; maybe-make-box-delay is used to box forms that are "expensive" to
  585. ;;; compute; maybe-make-box-value is used to box forms like constants
  586. ;;; or functions that are "cheap" to compute eagerly.
  587. ;;; Maybe-unbox is used to unbox a form that returns a boxed result.
  588.  
  589. (define (maybe-make-box-delay form unboxed?)
  590.   (if unboxed?
  591.       form
  592.       `(delay ,form)))
  593.  
  594. (define (maybe-make-box-value form unboxed?)
  595.   (if unboxed?
  596.       form
  597.       `(box ,form)))
  598.  
  599. (define (maybe-unbox form unboxed?)
  600.   (if unboxed?
  601.       `(force ,form)
  602.       form))
  603.  
  604.  
  605. ;;; These two var slots are filled in lazily by the code generator,
  606. ;;; since most vars generated don't need them.  You should always
  607. ;;; use these functions instead of accessing the structure slot
  608. ;;; directly.
  609.  
  610. (define (fullname var)
  611.   (or (var-fullname var)
  612.       (setf (var-fullname var)
  613.         (if (var-toplevel? var)
  614.         ;; For toplevel names, use module name glued onto base names.
  615.         ;; These are always interned symbols.
  616.         (if (def-core? var)
  617.             (symbol-append '|*Core:| (def-name var))
  618.             (symbol-append (def-module var) '\: (def-name var)))
  619.         ;; Otherwise, make sure we have a gensym.
  620.         ;; The uniquification of interned symbols is required
  621.         ;; because there may be multiple nested bindings of the
  622.         ;; same name, and we want to be able to distinguish between
  623.         ;; the different bindings for debugging purposes.
  624.         (let ((name  (def-name var)))
  625.           (if (gensym? name)
  626.               name
  627.               (gensym (symbol->string name))))))
  628.       ))
  629.  
  630. (define (optname var)
  631.   (or (var-optimized-entry var)
  632.       (setf (var-optimized-entry var)
  633.         (if (var-toplevel? var)
  634.         (string->symbol
  635.           (string-append "Function "
  636.                  (symbol->string (fullname var))))
  637.         (string->gensym
  638.           (string-append "Local Function "
  639.                  (symbol->string (fullname var))))))
  640.       ))
  641.  
  642.  
  643.  
  644. ;;;======================================================================
  645. ;;; Exported functions
  646. ;;;======================================================================
  647.  
  648. ;;; This handles types exported to lisp from Haskell
  649. ;;; *** Is this really supposed to create variable bindings as
  650. ;;; *** opposed to function bindings???
  651. ;;; *** I assume all of these functions want strict arguments and return
  652. ;;; *** strict results, even if the data structures contain boxed values.
  653.  
  654. (define (codegen-exported-types mods)
  655.   (let ((defs '()))
  656.     (dolist (m mods)
  657.       (dolist (a (module-alg-defs m))
  658.         (when (algdata-export-to-lisp? a)
  659.       (dolist (c (algdata-constrs a))
  660.         (setf defs (nconc (codegen-constr c) defs))))))
  661.     `(begin ,@defs)))
  662.  
  663. (define (codegen-constr c)
  664.   (let ((lisp-fns (con-lisp-fns c)))
  665.     (if c
  666.         (let ((res
  667.            `(,(codegen-lisp-predicate (car lisp-fns) c)
  668.          ,(codegen-lisp-constructor (cadr lisp-fns) c)
  669.          ,@(codegen-lisp-accessors
  670.             (cddr lisp-fns) (con-slot-strict? c) c 0))))
  671.       (when (memq 'codegen (dynamic *printers*))
  672.         (dolist (d res)
  673.           (pprint* d)))
  674.       res)
  675.     '())))
  676.  
  677. (define (codegen-lisp-predicate name c)
  678.   `(define (,name x)
  679.      ,(codegen-flic-is-constructor-aux c 'x)))
  680.  
  681. (define (codegen-lisp-constructor name c)
  682.   (let ((strictness (con-slot-strict? c))
  683.     (args       '())
  684.     (exps       '()))
  685.     (dolist (s strictness)
  686.       (let ((arg  (gensym)))
  687.     (push arg args)
  688.     (push (if s arg `(box ,arg)) exps)))
  689.     `(define (,name ,@(nreverse args))
  690.      ,(codegen-constructor-app-aux c (nreverse exps)))))
  691.  
  692. (define (codegen-lisp-accessors names strictness c i)
  693.   (declare (type fixnum i))
  694.   (if (null? names)
  695.       '()
  696.       (let ((body  (codegen-flic-sel-aux c i 'x)))
  697.     (when (not (car strictness))
  698.       (setf body `(force ,body)))
  699.     (cons `(define (,(car names) x) ,body)
  700.           (codegen-lisp-accessors (cdr names) (cdr strictness) c (+ i 1))))
  701.     ))
  702.  
  703.  
  704.  
  705. ;;; This allows the user to place lambda defined functions in ImportLispType
  706. ;;; Note: lambda applications without the funcall are valid in Common Lisp, 
  707. ;;; but not in mumble.  
  708.  
  709. (define (apply-maybe-lambda fn args)
  710.   (if (and (pair? fn)
  711.        (eq? (car fn) 'lambda))
  712.       `(funcall ,fn ,@args)
  713.       `(,fn ,@args)))
  714.